Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue68/Alfresco/AAPasTok.pas

Pascal/Delphi Source File | 2001-03-04 | 12.4 KB | 440 lines

unit AAPasTok;

interface

uses
  SysUtils,
  AAChrStm,
  AAHshLnP;

type
  TaaPascalToken = ( {types of Pascal tokens...}
    ptInvalidToken,  {..some kind of error}
    ptEndOfFile,     {..end of file}
    ptKeyword,       {..keyword, eg, if, while, do, ...}
    ptIdentifier,    {..identifier}
    ptString,        {..string or character constant}
    ptHexNumber,     {..number in hex, starts with $}
    ptNumber,        {..sequence of digits, maybe with radix point}
    ptComment,       {..comment, any type}
    ptComma,         {..comma: ,}
    ptSemicolon,     {..semicolon: ;}
    ptColon,         {..colon: :}
    ptPeriod,        {..period: .}
    ptRange,         {..range: ..}
    ptEquals,        {..equals char: =}
    ptNotEquals,     {..not equals: <>}
    ptLess,          {..less than: <}
    ptLessEqual,     {..less than or equal: <=}
    ptGreater,       {..greater than: >}
    ptGreaterEqual,  {..greater than or equal: >=}
    ptAssign,        {..assignment: :=}
    ptOpenParen,     {..open parenthesis: (}
    ptCloseParen,    {..close parenthesis: )}
    ptOpenBracket,   {..open bracket: [}
    ptCloseBracket,  {..close bracket: ]}
    ptCaret,         {..caret: ^}
    ptHash,          {..hash: #}
    ptAddress,       {..ampersand: @}
    ptPlus,          {..addition: +}
    ptMinus,         {..subtraction: -}
    ptMultiply,      {..multiplication: *}
    ptDivide);       {..division: /}

type
  TaaPascalParser = class
    private
      FInStrm   : TaaInCharStream;
      FKeywords : TaaHashTableLinear;
    protected
      procedure ppInitKeywords;
    public
      constructor Create(aInStm : TaaInCharStream);
      destructor Destroy; override;

      procedure GetToken(var aTokenType : TaaPascalToken;
                         var aToken     : string);
  end;


procedure AAGetToken(aInStm     : TaaInCharStream;
                 var aTokenType : TaaPascalToken;
                 var aToken     : string);

implementation

const
  KeywordCount = 106;
  KeywordList : array [0..pred(KeywordCount)] of string = (
    {reserved words}
    'AND', 'ARRAY', 'AS', 'ASM', 'BEGIN', 'CASE', 'CLASS', 'CONST',
    'CONSTRUCTOR', 'DESTRUCTOR', 'DISPINTERFACE', 'DIV', 'DO',
    'DOWNTO', 'ELSE', 'END', 'EXCEPT', 'EXPORTS', 'FILE',
    'FINALIZATION', 'FINALLY', 'FOR', 'FUNCTION', 'GOTO', 'IF',
    'IMPLEMENTATION', 'IN', 'INHERITED', 'INITIALIZATION', 'INLINE',
    'INTERFACE', 'IS', 'LABEL', 'LIBRARY', 'MOD', 'NIL', 'NOT',
    'OBJECT', 'OF', 'OR', 'OUT', 'PACKED', 'PROCEDURE', 'PROGRAM',
    'PROPERTY', 'RAISE', 'RECORD', 'REPEAT', 'RESOURCESTRING', 'SET',
    'SHL', 'SHR', 'STRING', 'THEN', 'THREADVAR', 'TO', 'TRY', 'TYPE',
    'UNIT', 'UNTIL', 'USES', 'VAR', 'WHILE', 'WITH', 'XOR',
    {directives}
    'ABSOLUTE', 'ABSTRACT', 'ASSEMBLER', 'AUTOMATED', 'CDECL',
    'CONTAINS', 'DEFAULT', 'DISPID', 'DYNAMIC', 'EXPORT', 'EXTERNAL',
    'FAR', 'FORWARD', 'IMPLEMENTS', 'INDEX', 'MESSAGE', 'NAME',
    'NEAR', 'NODEFAULT', 'OVERLOAD', 'OVERRIDE', 'PACKAGE', 'PASCAL',
    'PRIVATE', 'PROTECTED', 'PUBLIC', 'PUBLISHED', 'READ', 'READONLY',
    'REGISTER', 'REINTRODUCE', 'REQUIRES', 'RESIDENT', 'SAFECALL',
    'STDCALL', 'STORED', 'VIRTUAL', 'WRITE', 'WRITEONLY',
    {others}
    'AT', 'ON'
    );

{===TaaPascalParser==================================================}
constructor TaaPascalParser.Create(aInStm : TaaInCharStream);
begin
  {create the ancestor}
  inherited Create;

  {save the stream}
  FInStrm := aInstm;

  {create the keywords list}
  FKeywords := TaaHashTableLinear.Create(199, AAELFHash);
  ppInitKeywords;

end;
{--------}
destructor TaaPascalParser.Destroy;
begin
  {destroy the keywords list}
  FKeywords.Free;
  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
procedure TaaPascalParser.GetToken(var aTokenType : TaaPascalToken;
                                   var aToken     : string);
var
  DummyObj : pointer;
begin
  AAGetToken(FInStrm, aTokenType, aToken);
  if (aTokenType = ptIdentifier) then
    if FKeywords.Find(UpperCase(aToken), DummyObj) then
      aTokenType := ptKeyword;
end;
{--------}
procedure TaaPascalParser.ppInitKeywords;
var
  i : integer;
begin
  Assert(FKeywords <> nil,
         'ppInitKeywords cannot be called with nil hash table');
  for i := 0 to pred(KeywordCount) do
    FKeywords.Insert(KeyWordList[i], nil);
end;
{====================================================================}


{===Helper routines==================================================}
procedure ReadNumber(aInStm : TaaInCharStream;
                 var aToken : string);
var
  Ch : char;
  State : (BeforeDecPt, GotDecPt, AfterDecPt, Finished);
begin
  State := BeforeDecPt;
  while (State <> Finished) do begin
    Ch := aInStm.GetChar;
    if (Ch = #0) then begin
      State := Finished;
      aInStm.PutBackChar(Ch);
    end
    else begin
      case State of
        BeforeDecPt :
          begin
            if (Ch = '.') then begin
              State := GotDecPt;
            end
            else if (Ch < '0') or (Ch > '9') then begin
              State := Finished;
              aInStm.PutBackChar(Ch);
            end
            else
              aToken := aToken + Ch;
          end;
        GotDecPt :
          begin
            if (Ch = '.') then begin
              aInStm.PutBackChar(Ch);
              aInStm.PutBackChar(Ch);
              State := Finished;
            end
            else begin
              aToken := aToken + '.';
              aToken := aToken + Ch;
              State := AfterDecPt;
            end;
          end;
        AfterDecPt :
          begin
            if (Ch < '0') or (Ch > '9') then begin
              State := Finished;
              aInStm.PutBackChar(Ch);
            end
            else
              aToken := aToken + Ch;
          end;
      end;
    end;
  end;
end;
{--------}
procedure ReadHexNumber(aInStm : TaaInCharStream;
                    var aToken : string);
var
  Ch : char;
  State : (NormalScan, Finished);
begin
  State := NormalScan;
  while (State <> Finished) do begin
    Ch := aInStm.GetChar;
    if (Ch = #0) then begin
      State := Finished;
      aInStm.PutBackChar(Ch);
    end
    else begin
      case State of
        NormalScan :
          begin
            if not (Ch in ['A'..'F', 'a'..'f', '0'..'9']) then begin
              State := Finished;
              aInStm.PutBackChar(Ch);
            end
            else
              aToken := aToken + Ch;
          end;
      end;
    end;
  end;
end;
{--------}
procedure ReadIdentifier(aInStm : TaaInCharStream;
                     var aToken : string);
var
  Ch : char;
begin
  Ch := aInStm.GetChar;
  while Ch in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do begin
    aToken := aToken + Ch;
    Ch := aInStm.GetChar;
  end;
  aInStm.PutBackchar(Ch);
end;
{--------}
procedure ReadString(aInStm : TaaInCharStream;
                 var aToken : string);
var
  Ch : char;
begin
  Ch := aInStm.GetChar;
  while (Ch <> '''') and (Ch <> #0) do begin
    aToken := aToken + Ch;
    Ch := aInStm.GetChar;
  end;
  if (Ch = '''') then
    aToken := aToken + Ch
  else
    aInStm.PutBackchar(Ch);
end;
{--------}
procedure ReadBraceComment(aInStm : TaaInCharStream;
                       var aToken : string);
var
  Ch : char;
begin
  Ch := aInStm.GetChar;
  while (Ch <> '}') and (Ch <> #0) do begin
    aToken := aToken + Ch;
    Ch := aInStm.GetChar;
  end;
  if (Ch = '}') then
    aToken := aToken + Ch
  else
    aInStm.PutBackchar(Ch);
end;
{--------}
procedure ReadSlashComment(aInStm : TaaInCharStream;
                       var aToken : string);
var
  Ch : char;
begin
  Ch := aInStm.GetChar;
  while (Ch <> #10) and (Ch <> #0) do begin
    aToken := aToken + Ch;
    Ch := aInStm.GetChar;
  end;
  aInStm.PutBackchar(Ch);
end;
{--------}
procedure ReadParenComment(aInStm : TaaInCharStream;
                       var aToken : string);
var
  Ch : char;
  State : (NormalScan, GotStar, Finished);
begin
  State := NormalScan;
  while (State <> Finished) do begin
    Ch := aInStm.GetChar;
    if (Ch = #0) then begin
      State := Finished;
      aInStm.PutBackChar(Ch);
    end
    else begin
      aToken := aToken + Ch;
      case State of
        NormalScan :
          if (Ch = '*') then
            State := GotStar;
        GotStar :
          if (Ch = ')') then
            State := Finished
          else
            State := NormalScan;
      end;
    end;
  end;
end;
{====================================================================}


{===Interface routine================================================}
procedure AAGetToken(aInStm     : TaaInCharStream;
                 var aTokenType : TaaPascalToken;
                 var aToken     : string);
var
  Ch : char;
begin
  {assume we have an invalid token}
  aTokenType := ptInvalidToken;
  aToken := '';
  {ignore any whitespace prior to the token}
  Ch := aInStm.GetChar;
  while (Ch <> #0) and (Ch <= ' ') do
    Ch := aInStm.GetChar;
  {if we've reached end-of-file, exit returning that token type}
  if (Ch = #0) then begin
    aTokenType := ptEndOfFile;
    Exit;
  end;
  {parse the token based on the current character}
  case Ch of
    '#' : aTokenType := ptHash;
    '$' : begin
            aTokenType := ptNumber;
            aToken := Ch;
            ReadHexNumber(aInStm, aToken);
          end;
    '''': begin
            aTokenType := ptString;
            aToken := '''';
            ReadString(aInStm, aToken);
          end;
    '(' : begin
            Ch := aInStm.GetChar;
            if (Ch <> '*') then begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptOpenParen;
            end
            else begin
              aTokenType := ptComment;
              aToken := '(*';
              ReadParenComment(aInStm, aToken);
            end;
          end;
    ')' : aTokenType := ptCloseParen;
    '*' : aTokenType := ptMultiply;
    '+' : aTokenType := ptPlus;
    ',' : aTokenType := ptComma;
    '-' : aTokenType := ptMinus;
    '.' : begin
            Ch := aInStm.GetChar;
            if (Ch = '.') then
              aTokenType := ptRange
            else begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptPeriod;
            end;
          end;
    '/' : begin
            Ch := aInStm.GetChar;
            if (Ch <> '/') then begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptDivide;
            end
            else begin
              aTokenType := ptComment;
              aToken := '//';
              ReadSlashComment(aInStm, aToken);
            end;
          end;
    '0'..'9' :
          begin
            aTokenType := ptNumber;
            aToken := Ch;
            ReadNumber(aInStm, aToken);
          end;
    ':' : begin
            Ch := aInStm.GetChar;
            if (Ch = '=') then
              aTokenType := ptAssign
            else begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptColon;
            end;
          end;
    ';' : aTokenType := ptSemicolon;
    '<' : begin
            Ch := aInStm.GetChar;
            if (Ch = '=') then
              aTokenType := ptLessEqual
            else if (Ch = '>') then
              aTokenType := ptNotEquals
            else begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptLess;
            end;
          end;
    '=' : aTokenType := ptEquals;
    '>' : begin
            Ch := aInStm.GetChar;
            if (Ch = '=') then
              aTokenType := ptGreaterEqual
            else begin
              aInStm.PutBackChar(Ch);
              aTokenType := ptLess;
            end;
          end;
    '@' : aTokenType := ptAddress;
    'A'..'Z', 'a'..'z', '_' :
          begin
            aTokenType := ptIdentifier;
            aToken := Ch;
            ReadIdentifier(aInStm, aToken);
          end;
    '[' : aTokenType := ptOpenBracket;
    ']' : aTokenType := ptCloseBracket;
    '^' : aTokenType := ptCaret;
    '{' : begin
            aTokenType := ptComment;
            aToken := '{';
            ReadBraceComment(aInStm, aToken);
          end;
  end;
  Assert(aTokenType <> ptInvalidToken,
         'Managed to find an invalid token.');
end;
{====================================================================}

end.